﻿(*   Copyright 2011 Alexander Omelchuk
 *
 *   Licensed under the Apache License, Version 2.0 (the "License");
 *   you may not use this file except in compliance with the License.
 *   You may obtain a copy of the License at
 *
 *       http://www.apache.org/licenses/LICENSE-2.0
 *
 *   Unless required by applicable law or agreed to in writing, software
 *   distributed under the License is distributed on an "AS IS" BASIS,
 *   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 *   See the License for the specific language governing permissions and
 *   limitations under the License.
 *)

namespace Lisp
open System.Linq.Expressions
open EvalHelpers
open Eval

module SpecialOps =
  type FunctionInfo = {
     Name       : string
     LambdaList : LambdaList
     LexEnv     : LEnvironment
     Parameters : ParameterExpression array
     FuncVar    : ParameterExpression
     Body       : LambdaExpression option
    }

  type FletType =
   | Flet     = 0
   | Labels   = 1
   | Macrolet = 2

  let createFunctionInfo (name, lambdaList:LambdaList, fletEnv:LEnvironment, funEnv, type') =
    let newEnv = LEnvironment(funEnv)
    // add function parameters to lexical environment
    let parameters = Seq.toArray (seq {
      yield Expression.Parameter(typeof<IDynamicEnvironment>)
      yield! Seq.map newEnv.CreateVar lambdaList.Args
      })
    // easy way to get function type from arguments is
    // to build LambdaExpression and take its type
    let stub = Expression.Lambda(Expression.Variable(typeof<SExpr>), parameters)
    let funcVar = Expression.Variable(stub.Type, name)
    if type' <> FletType.Macrolet then 
      fletEnv.CreateFunction name (Function(lambdaList,funcVar))
    { Name = name; LambdaList = lambdaList; LexEnv = newEnv;
      Parameters = parameters; FuncVar = funcVar; Body = None}

  let createFunctionBody (info:FunctionInfo, body) =
    doInLexical info.LexEnv (fun () ->
      dEnv <- info.Parameters.[0]
      // add aux parameters to lexical environment
      let auxVars = List.map (fun (name,_) -> lEnv.CreateVar name) info.LambdaList.Aux
      let body = Expression.Block(auxVars, seq {
        // init aux parameters
        yield! List.map2 (fun var (_,value) -> Expression.Assign(var, eval value) :> Expression)
                         auxVars info.LambdaList.Aux
        yield progn body})
      { info with Body = Some(Expression.Lambda(body, info.Parameters)) })

  let createMacroBody (info, body) =
   let body = createFunctionBody(info, body).Body.Value.Compile()
   lEnv.CreateFunction info.Name (Macro(info.LambdaList,body))

  let quote = function
    | Lst(expr,Nil) -> Expression.Constant(expr, typeof<SExpr>) :> Expression
    | Nil           -> raiseArgError tooFewParams
    | _             -> raiseArgError tooManyParams

  let ``if`` args =
    let cond, tClause, nilClause =
      match args with
      | Lst3(cond,tClause,nilClause,Nil) -> cond, tClause, nilClause
      | Lst2(cond,tClause,Nil)           -> cond, tClause, Nil
      | Lst _ | Nil                      -> raiseArgError tooFewParams
      | _                                -> raiseArgError tooManyParams
    // if eval cond = Nil then eval nilClause else eval tClause
    Expression.Condition(IsNil(eval cond), eval nilClause, eval tClause) :> Expression

  let setq =
    let rec checkArgs = function
      | Lst2(dest,_,rest) -> checkMutable dest; checkArgs rest
      | Lst(dest,Nil) -> raiseArgError oddParams
      | _ -> ()
    let rec foldSet args =
      seq {
        match args with
        | Lst2(dest,expr,rest) ->
           // getVar (symbolName dest) <- eval expr
           yield Expression.Assign(getVar (symbolName dest), eval expr) :> Expression
           yield! foldSet rest
        | _ -> () }
    fun args ->
      checkArgs args
      match args with
       | Lst _ -> Expression.Block(foldSet args) :> Expression
       | _     -> NilConstant
  
  let ``let`` isLet = function
    | Lst(vars,forms) ->
      checkList vars
      let env' = new LEnvironment(lEnv)
      let initEnv = if isLet then lEnv else env'
      // remembers bindings in new lexical environment
      // and returns these bindings with init values for them
      let handleVarDef varDef =
        let (var, initForm) = getVarDef varDef
        env'.CreateVar var, evalInLexical initEnv initForm
      let lexicalVars = Seq.toList (mapSeq handleVarDef vars)
      if lexicalVars.IsEmpty then doInLexical env' (fun () -> progn forms)
      else
       Expression.Block(
        List.map (fun (var,_) -> var) lexicalVars,
        seq {
          yield! List.map (fun (var,value) -> Expression.Assign(var,value):>Expression) lexicalVars
          yield doInLexical env' (fun () -> progn forms)
            }) :> Expression
    | _ -> raiseArgError tooFewParams None

  let flet type' = function
    | Lst(funs,forms) ->
      checkList funs
      let newLEnv = new LEnvironment(lEnv)
      let fEnv = if type' = FletType.Labels then newLEnv else lEnv
      let handleFunDef funDef = 
        let name, lambdaList, body =
          match funDef with
          | Lst2(name,lambdaList,rest) ->
            symbolName name, getLambdaList true lambdaList, rest
          | x -> raiseExprError illegalFunDef x
        //let documentation, body =
        //  match body with
        //  | Lst(_,Nil) -> "", body
        //  | Lst(doc,f) when doc :? string -> doc, f
        //  | _          -> "", body
        createFunctionInfo(name, lambdaList, newLEnv, fEnv,  type'), body

      if type' = FletType.Macrolet then
        let macros = Lst.mapSeq handleFunDef funs |> Seq.toList
        doInLexical newLEnv (fun () -> 
          List.iter createMacroBody macros
          progn forms)
      else
        let functions =
          mapSeq handleFunDef funs
          |> Seq.toList
          |> List.map createFunctionBody
        doInLexical newLEnv (fun () ->
          Expression.Block(
            List.map (fun info -> info.FuncVar) functions,
            seq {
              yield! List.map (fun info -> Expression.Assign(info.FuncVar, info.Body.Value) :> Expression) functions
              yield progn forms
            }) :> Expression)

    | _ -> raiseArgError tooFewParams

  let block = function
    | Lst(name,forms) ->
      let envId, name, ex =
        Expression.Variable(typeof<int>, "_BLOCKNAME"),
        symbolName name,
        Expression.Parameter(typeof<ReturnFrom>)
      let newLEnv = new LEnvironment(Some lEnv, Some (name, envId))

      doInLexical newLEnv (fun () ->
        Expression.Block(
          [| envId |],
          Expression.Assign(envId, Expression.Constant(newLEnv.Id)) :> Expression,
          Expression.TryCatch(
            progn forms,
            Expression.Catch(
              ex,
              Expression.Condition(
                Expression.Equal(envId, Expression.Field(ex,"envId")),
                Expression.Field(ex, "result"),
                Expression.Rethrow(typeof<SExpr>)))) :> Expression
          ) :> Expression)

    | _ -> raiseArgError tooFewParams

  let ``return-from`` =
    // we check block name both at compile time (to show error if not found) 
    let rec findBlockName blockName (env:LEnvironment) =
      match env.BlockSignature with
      | Some (name, target) when name=blockName -> target :> Expression
      | _ -> match env.Parent with
             | None -> raiseExprError noBlockFound (Id blockName)
             | Some parent -> findBlockName blockName parent
    let returnFromConstructor = typeof<ReturnFrom>.GetConstructors().[0]
    fun (x:SExpr) ->
    match x with
    | Lst(name,args1) ->
      let blockName = findBlockName (symbolName name) lEnv
      let value =
        match args1 with
        | Lst(value,Nil) -> eval value
        | Lst _ -> raiseArgError tooManyParams
        | _ -> NilConstant
      // and at runtime (to find a right block)
      Expression.Throw(
        Expression.New(returnFromConstructor, [| blockName; value |]),
        typeof<SExpr>) :> Expression
      
    | _ -> raiseArgError tooFewParams

  let ``unwind-protect`` = function
    // try (eval form) finally (progn clean)
    | Lst(form,clean) -> Expression.TryFinally(eval form, progn clean) :> Expression
    | _ -> raiseArgError tooFewParams

  let throw =
    let throwConstructor = typeof<Throw>.GetConstructors().[0]
    fun (x:SExpr) ->
    match x with
    | Lst2(tag,result,Nil) ->
      // raise Throw(eval tag, eval result)
      Expression.Throw(
        Expression.New(throwConstructor, [| eval tag; eval result |]),
        typeof<SExpr>) :> Expression
    | Lst(_,Nil) -> raiseArgError tooFewParams
    | Lst _      -> raiseArgError tooManyParams
    | _          -> raiseArgError tooFewParams

  let catch = function 
    | Lst(tag,forms) ->
      // let catchTag = eval tag
      // try progn forms
      // with | Throw as x ->
      //        if catchTag = x.tag
      //        then return x.result
      //        else reraise
      let catchTag, ex = 
        Expression.Variable(typeof<SExpr>, "_CATCHTAG"),
        Expression.Parameter(typeof<Throw>)
      Expression.Block(
        Seq.ofArray [| catchTag |],
        Expression.Assign(catchTag, eval tag) :> Expression,
        Expression.TryCatch(
          progn forms,
          Expression.Catch(
            ex,
            Expression.Condition(
              exprEquals catchTag (Expression.Field(ex,"tag")),
              Expression.Field(ex, "result"),
              Expression.Rethrow(typeof<SExpr>)))) :> Expression
         ) :> Expression
    | _ -> raiseArgError tooFewParams